home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / numerical / slatec / zwrsk.lisp < prev   
Encoding:
Text File  |  2003-02-09  |  3.4 KB  |  93 lines
  1. ;;; Compiled by f2cl version 2.0 beta 2002-05-06
  2. ;;; 
  3. ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
  4. ;;;           (:coerce-assigns :as-needed) (:array-type ':simple-array)
  5. ;;;           (:array-slicing nil) (:declare-common nil)
  6. ;;;           (:float-format double-float))
  7.  
  8. (in-package "SLATEC")
  9.  
  10.  
  11. (defun zwrsk (zrr zri fnu kode n yr yi nz cwr cwi tol elim alim)
  12.   (declare (type (simple-array double-float (*)) yr yi)
  13.            (type f2cl-lib:integer4 kode n nz)
  14.            (type (simple-array double-float (*)) cwr cwi)
  15.            (type double-float zrr zri fnu tol elim alim))
  16.   (prog ((i 0) (nw 0) (act 0.0) (acw 0.0) (ascle 0.0) (cinui 0.0) (cinur 0.0)
  17.          (csclr 0.0) (cti 0.0) (ctr 0.0) (c1i 0.0) (c1r 0.0) (c2i 0.0)
  18.          (c2r 0.0) (pti 0.0) (ptr 0.0) (ract 0.0) (sti 0.0) (str 0.0))
  19.     (declare
  20.      (type double-float str sti ract ptr pti c2r c2i c1r c1i ctr cti csclr
  21.       cinur cinui ascle acw act)
  22.      (type f2cl-lib:integer4 nw i))
  23.     (setf nz 0)
  24.     (multiple-value-bind
  25.         (var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-7 var-8 var-9 var-10)
  26.         (zbknu zrr zri fnu kode 2 cwr cwi nw tol elim alim)
  27.       (declare
  28.        (ignore var-0 var-1 var-2 var-3 var-4 var-5 var-6 var-8 var-9 var-10))
  29.       (setf nw var-7))
  30.     (if (/= nw 0) (go label50))
  31.     (zrati zrr zri fnu n yr yi tol)
  32.     (setf cinur 1.0)
  33.     (setf cinui 0.0)
  34.     (if (= kode 1) (go label10))
  35.     (setf cinur (cos zri))
  36.     (setf cinui (sin zri))
  37.    label10
  38.     (setf acw
  39.             (zabs (f2cl-lib:fref cwr (2) ((1 2)))
  40.              (f2cl-lib:fref cwi (2) ((1 2)))))
  41.     (setf ascle (/ (* 1000.0 (f2cl-lib:d1mach 1)) tol))
  42.     (setf csclr 1.0)
  43.     (if (> acw ascle) (go label20))
  44.     (setf csclr (/ 1.0 tol))
  45.     (go label30)
  46.    label20
  47.     (setf ascle (/ 1.0 ascle))
  48.     (if (< acw ascle) (go label30))
  49.     (setf csclr tol)
  50.    label30
  51.     (setf c1r (* (f2cl-lib:fref cwr (1) ((1 2))) csclr))
  52.     (setf c1i (* (f2cl-lib:fref cwi (1) ((1 2))) csclr))
  53.     (setf c2r (* (f2cl-lib:fref cwr (2) ((1 2))) csclr))
  54.     (setf c2i (* (f2cl-lib:fref cwi (2) ((1 2))) csclr))
  55.     (setf str (f2cl-lib:fref yr (1) ((1 n))))
  56.     (setf sti (f2cl-lib:fref yi (1) ((1 n))))
  57.     (setf ptr (- (* str c1r) (* sti c1i)))
  58.     (setf pti (+ (* str c1i) (* sti c1r)))
  59.     (setf ptr (+ ptr c2r))
  60.     (setf pti (+ pti c2i))
  61.     (setf ctr (- (* zrr ptr) (* zri pti)))
  62.     (setf cti (+ (* zrr pti) (* zri ptr)))
  63.     (setf act (zabs ctr cti))
  64.     (setf ract (/ 1.0 act))
  65.     (setf ctr (* ctr ract))
  66.     (setf cti (* (- cti) ract))
  67.     (setf ptr (* cinur ract))
  68.     (setf pti (* cinui ract))
  69.     (setf cinur (- (* ptr ctr) (* pti cti)))
  70.     (setf cinui (+ (* ptr cti) (* pti ctr)))
  71.     (f2cl-lib:fset (f2cl-lib:fref yr (1) ((1 n))) (* cinur csclr))
  72.     (f2cl-lib:fset (f2cl-lib:fref yi (1) ((1 n))) (* cinui csclr))
  73.     (if (= n 1) (go end_label))
  74.     (f2cl-lib:fdo (i 2 (f2cl-lib:int-add i 1))
  75.                   ((> i n) nil)
  76.       (tagbody
  77.         (setf ptr (- (* str cinur) (* sti cinui)))
  78.         (setf cinui (+ (* str cinui) (* sti cinur)))
  79.         (setf cinur ptr)
  80.         (setf str (f2cl-lib:fref yr (i) ((1 n))))
  81.         (setf sti (f2cl-lib:fref yi (i) ((1 n))))
  82.         (f2cl-lib:fset (f2cl-lib:fref yr (i) ((1 n))) (* cinur csclr))
  83.         (f2cl-lib:fset (f2cl-lib:fref yi (i) ((1 n))) (* cinui csclr))
  84.        label40))
  85.     (go end_label)
  86.    label50
  87.     (setf nz -1)
  88.     (if (= nw -2) (setf nz -2))
  89.     (go end_label)
  90.    end_label
  91.     (return (values nil nil nil nil nil nil nil nz nil nil nil nil nil))))
  92.  
  93.